home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / DBPRGRSS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  15.6 KB  |  561 lines

  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {                                                       }
  10. {*******************************************************}
  11.  
  12. unit DbPrgrss;
  13.  
  14. interface
  15.  
  16. {$I RX.INC}
  17. {$T-}
  18.  
  19. uses Classes, {$IFDEF WIN32} Bde, {$ELSE} DbiTypes, DbiProcs, {$ENDIF WIN32}
  20.   Controls, DB, DBTables, RxTimer;
  21.  
  22. type
  23.   TOnMessageChange = procedure(Sender: TObject; const Msg: string) of object;
  24.   TOnPercentChange = procedure(Sender: TObject; PercentDone: Integer) of object;
  25.   TOnProgressEvent = procedure(Sender: TObject; var AbortQuery: Boolean) of object;
  26. {$IFDEF WIN32}
  27.   TOnTraceEvent = procedure(Sender: TObject; Flag: TTraceFlag;
  28.     const Msg: string) of object;
  29. {$ENDIF WIN32}
  30.  
  31. { TDBProgress }
  32.  
  33.   TDBProgress = class(TComponent)
  34.   private
  35.     FActive: Boolean;
  36.     FStartTime: Longint;
  37.     FTimer: TRxTimer;
  38.     FWaitCursor: TCursor;
  39.     FGauge: TControl;
  40.     FMessageControl: TControl;
  41.     FStreamedValue: Boolean;
  42.     FGenProgressCallback: TObject;
  43.     FQryProgressCallback: TObject;
  44.     FOnMessageChange: TOnMessageChange;
  45.     FOnPercentChange: TOnPercentChange;
  46.     FOnProgress: TOnProgressEvent;
  47. {$IFDEF WIN32}
  48.     FTraceFlags: TTraceFlags;
  49.     FTraceCallback: TObject;
  50.     FTrace: Boolean;
  51.     FOnTrace: TOnTraceEvent;
  52.     FSessionName: string;
  53.     FSessionLink: TObject;
  54.     procedure SetTrace(Value: Boolean);
  55.     procedure SetTraceFlags(Value: TTraceFlags);
  56.     function TraceCallBack(CBInfo: Pointer): CBRType;
  57.     function GetDBSession: TSession;
  58.     procedure SetSessionName(const Value: string);
  59.     procedure Activate;
  60.     procedure Deactivate;
  61. {$ENDIF WIN32}
  62.     procedure FreeTimer;
  63.     procedure StartTimer;
  64.     procedure TimerExpired(Sender: TObject);
  65.     function GenProgressCallback(CBInfo: Pointer): CBRType;
  66.     function QryProgressCallback(CBInfo: Pointer): CBRType;
  67.     procedure SetActive(Value: Boolean);
  68.     procedure SetPercent(Value: Integer);
  69.     procedure SetMessage(const Value: string);
  70.     procedure SetMessageControl(Value: TControl);
  71.     procedure SetGauge(Value: TControl);
  72.   protected
  73.     procedure Notification(AComponent: TComponent; AOperation: TOperation); override;
  74.     procedure Loaded; override;
  75.   public
  76.     constructor Create(AOwner: TComponent); override;
  77.     destructor Destroy; override;
  78.     function ProgressMsgValue(const Msg: string): Longint;
  79.   published
  80.     property Active: Boolean read FActive write SetActive default True;
  81.     property WaitCursor: TCursor read FWaitCursor write FWaitCursor default crHourGlass;
  82.     property MessageControl: TControl read FMessageControl write SetMessageControl;
  83.     property Gauge: TControl read FGauge write SetGauge;
  84. {$IFDEF WIN32}
  85.     property SessionName: string read FSessionName write SetSessionName;
  86.     property Trace: Boolean read FTrace write SetTrace default False;
  87.     property TraceFlags: TTraceFlags read FTraceFlags write SetTraceFlags default [];
  88.     property OnTrace: TOnTraceEvent read FOnTrace write FOnTrace;
  89. {$ENDIF WIN32}
  90.     property OnMessageChange: TOnMessageChange read FOnMessageChange write FOnMessageChange;
  91.     property OnPercentChange: TOnPercentChange read FOnPercentChange write FOnPercentChange;
  92.     property OnProgress: TOnProgressEvent read FOnProgress write FOnProgress;
  93.   end;
  94.  
  95. { TDBCallback - for internal use only }
  96.  
  97. type
  98.   TDBCallbackEvent = function(CBInfo: Pointer): CBRType of object;
  99.   TDBCallbackChain = (dcOnlyOnce, dcChain, dcReplace);
  100.  
  101.   TDBCallback = class(TObject)
  102.   private
  103.     FOwner: TObject;
  104.     FCBType: CBType;
  105.     FCBBuf: Pointer;
  106.     FCBBufLen: Cardinal;
  107.     FOldCBData: Longint;
  108.     FOldCBBuf: Pointer;
  109.     FOldCBBufLen: Word;
  110.     FOldCBFunc: Pointer;
  111.     FInstalled: Boolean;
  112.     FChain: TDBCallbackChain;
  113.     FCallbackEvent: TDBCallbackEvent;
  114.   protected
  115.     function Invoke(CallType: CBType; var CBInfo: Pointer): CBRType;
  116.   public
  117.     constructor Create(AOwner: TObject; CBType: CBType;
  118.       CBBufSize: Cardinal; CallbackEvent: TDBCallbackEvent;
  119.       Chain: TDBCallbackChain);
  120.     destructor Destroy; override;
  121.   end;
  122.  
  123. implementation
  124.  
  125. uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, Str16, {$ENDIF WIN32}
  126.   Forms, SysUtils, StdCtrls, Dialogs, MaxMin, RxPrgrss, BdeUtils;
  127.  
  128. const
  129.   cbQRYPROGRESS = cbRESERVED4;
  130.  
  131. { TDBCallback }
  132.  
  133. function BdeCallBack(CallType: CBType; Data: Longint;
  134.   {$IFNDEF WIN32} var {$ENDIF} CBInfo: Pointer): CBRType;
  135.   {$IFDEF WIN32} stdcall; {$ELSE} export; {$ENDIF WIN32}
  136. begin
  137.   if Data <> 0 then begin
  138.     Result := TDBCallback(Data).Invoke(CallType, CBInfo);
  139.   end
  140.   else Result := cbrUSEDEF;
  141. end;
  142.  
  143. constructor TDBCallback.Create(AOwner: TObject; CBType: CBType;
  144.   CBBufSize: Cardinal; CallbackEvent: TDBCallbackEvent;
  145.   Chain: TDBCallbackChain);
  146. begin
  147.   FOwner := AOwner;
  148.   FCBType := CBType;
  149.   FCallbackEvent := CallbackEvent;
  150. {$IFDEF WIN32}
  151.   DbiGetCallBack(nil, FCBType, @FOldCBData, @FOldCBBufLen, @FOldCBBuf,
  152.     pfDBICallBack(FOldCBFunc));
  153. {$ELSE}
  154.   DbiGetCallBack(nil, FCBType, FOldCBData, FOldCBBufLen, FOldCBBuf,
  155.     @FOldCBFunc);
  156. {$ENDIF}
  157.   FChain := Chain;
  158.   if not Assigned(FOldCBFunc) then FOldCBBufLen := 0;
  159.   if not Assigned(FOldCBFunc) or (FChain in [dcChain, dcReplace]) then begin
  160.     FCBBufLen := Max(CBBufSize, FOldCBBufLen);
  161.     FCBBuf := AllocMem(FCBBufLen);
  162.     Check(DbiRegisterCallback(nil, FCBType, Longint(Self), FCBBufLen,
  163.       FCBBuf, BdeCallBack));
  164.     FInstalled := True;
  165.   end;
  166. end;
  167.  
  168. destructor TDBCallback.Destroy;
  169. begin
  170.   if FInstalled then begin
  171.     if Assigned(FOldCBFunc) and (FChain = dcChain) then
  172.     try
  173.       DbiRegisterCallback(nil, FCBType, FOldCBData, FOldCBBufLen,
  174.         FOldCBBuf, pfDBICallback(FOldCBFunc));
  175.     except
  176.     end
  177.     else DbiRegisterCallback(nil, FCBType, 0, 0, nil, nil);
  178.   end;
  179.   if FCBBuf <> nil then FreeMem(FCBBuf, FCBBufLen);
  180. end;
  181.  
  182. function TDBCallback.Invoke(CallType: CBType; var CBInfo: Pointer): CBRType;
  183. begin
  184.   Result := cbrUSEDEF;
  185.   if CallType = FCBType then
  186.   try
  187. {$IFDEF WIN32}
  188.     Result := FCallbackEvent(CBInfo);
  189. {$ELSE}
  190.     Result := FCallbackEvent(@CBInfo);
  191. {$ENDIF}
  192.   except
  193.     Application.HandleException(Self);
  194.   end;
  195.   if Assigned(FOldCBFunc) and (FChain = dcChain) then
  196.     Result := pfDBICallBack(FOldCBFunc)(CallType, FOldCBData, CBInfo);
  197. end;
  198.  
  199. { ProgressList }
  200.  
  201. const
  202.   ProgressList: TList = nil;
  203.  
  204. procedure SetWaitCursor;
  205. begin
  206. {$IFDEF WIN32}
  207.   if (GetCurrentThreadID = MainThreadID) then
  208. {$ENDIF}
  209.     Screen.Cursor := TDBProgress(ProgressList.Items[
  210.       ProgressList.Count - 1]).WaitCursor;
  211. end;
  212.  
  213. procedure AddProgress(Progress: TDBProgress);
  214. begin
  215.   if ProgressList = nil then ProgressList := TList.Create;
  216.   if ProgressList.IndexOf(Progress) = -1 then ProgressList.Add(Progress);
  217. end;
  218.  
  219. procedure RemoveProgress(Progress: TDBProgress);
  220. begin
  221.   if ProgressList <> nil then begin
  222.     ProgressList.Remove(Progress);
  223.     if ProgressList.Count = 0 then begin
  224.       ProgressList.Free;
  225.       ProgressList := nil;
  226.       Screen.Cursor := crDefault;
  227.     end;
  228.   end;
  229. end;
  230.  
  231. {$IFDEF WIN32}
  232.  
  233. { TSessionLink }
  234.  
  235. type
  236.   TSessionLink = class(TDatabase)
  237.   private
  238.     FProgress: TDBProgress;
  239.   public
  240.     destructor Destroy; override;
  241.   end;
  242.  
  243. destructor TSessionLink.Destroy;
  244. begin
  245.   if FProgress <> nil then begin
  246.     FProgress.FSessionLink := nil;
  247.     FProgress.Trace := False;
  248.     FProgress.Active := False;
  249.   end;
  250.   inherited Destroy;
  251. end;
  252.  
  253. {$ENDIF WIN32}
  254.  
  255. { TDBProgress }
  256.  
  257. constructor TDBProgress.Create(AOwner: TComponent);
  258. begin
  259.   inherited Create(AOwner);
  260.   FWaitCursor := crHourGlass;
  261.   FActive := True;
  262. end;
  263.  
  264. destructor TDBProgress.Destroy;
  265. begin
  266. {$IFDEF WIN32}
  267.   FOnTrace := nil;
  268.   Trace := False;
  269. {$ENDIF}
  270.   Active := False;
  271.   FreeTimer;
  272.   FTimer.Free;
  273.   inherited Destroy;
  274. end;
  275.  
  276. procedure TDBProgress.Loaded;
  277. begin
  278.   inherited Loaded;
  279.   FStreamedValue := True;
  280.   try
  281.     SetActive(FActive);
  282. {$IFDEF WIN32}
  283.     SetTrace(FTrace);
  284. {$ENDIF WIN32}
  285.   finally
  286.     FStreamedValue := False;
  287.   end;
  288. end;
  289.  
  290. procedure TDBProgress.TimerExpired(Sender: TObject);
  291. begin
  292.   FreeTimer;
  293.   SetPercent(0);
  294.   SetMessage('');
  295. end;
  296.  
  297. procedure TDBProgress.FreeTimer;
  298. begin
  299.   if FTimer <> nil then begin
  300.     FTimer.Enabled := False;
  301.     FStartTime := 0;
  302.   end;
  303.   Screen.Cursor := crDefault;
  304.   SetCursor(Screen.Cursors[crDefault]); { force update cursor }
  305. end;
  306.  
  307. procedure TDBProgress.StartTimer;
  308. begin
  309.   if (FTimer = nil) then begin
  310.     FTimer := TRxTimer.Create(Self);
  311.     FTimer.Interval := 500;
  312.   end;
  313.   with FTimer do begin
  314.     if not Enabled then FStartTime := GetTickCount;
  315.     OnTimer := TimerExpired;
  316.     Enabled := True;
  317.   end;
  318. end;
  319.  
  320. procedure TDBProgress.SetPercent(Value: Integer);
  321. begin
  322.   if Gauge <> nil then begin
  323.     SetProgressMax(Gauge, 100);
  324.     SetProgressValue(Gauge, Value);
  325.   end;
  326.   if Assigned(FOnPercentChange) then FOnPercentChange(Self, Value);
  327. end;
  328.  
  329. procedure TDBProgress.SetMessage(const Value: string);
  330. begin
  331.   if MessageControl <> nil then begin
  332.     TLabel(MessageControl).Caption := Value;
  333.     MessageControl.Refresh;
  334.   end;
  335.   if Assigned(FOnMessageChange) then FOnMessageChange(Self, Value);
  336. end;
  337.  
  338. procedure TDBProgress.SetActive(Value: Boolean);
  339. begin
  340.   if (FActive <> Value) or FStreamedValue then begin
  341.     if not (csDesigning in ComponentState) then begin
  342.       if Value then AddProgress(Self) else RemoveProgress(Self);
  343.       if (FGenProgressCallback = nil) and Value then begin
  344. {$IFDEF WIN32}
  345.         Activate;
  346. {$ENDIF}
  347.         FGenProgressCallback := TDBCallback.Create(Self, cbGENPROGRESS,
  348.           Max(SizeOf(CBPROGRESSDesc), SizeOf(DBIPATH) + SizeOf(Integer) * 4),
  349.           GenProgressCallback, dcChain);
  350.         FQryProgressCallback := TDBCallback.Create(Self, cbQRYPROGRESS,
  351.           SizeOf(DBIQryProgress), QryProgressCallback, dcChain);
  352.       end
  353.       else if not Value and (FGenProgressCallback <> nil) then begin
  354. {$IFDEF WIN32}
  355.         Sessions.CurrentSession := GetDBSession;
  356. {$ENDIF}
  357.         FGenProgressCallback.Free;
  358.         FGenProgressCallback := nil;
  359.         FQryProgressCallback.Free;
  360.         FQryProgressCallback := nil;
  361.         FreeTimer;
  362. {$IFDEF WIN32}
  363.         if not Trace then Deactivate;
  364. {$ENDIF}
  365.       end;
  366.     end;
  367.     FActive := Value;
  368.   end;
  369. end;
  370.  
  371. {$IFDEF WIN32}
  372.  
  373. procedure TDBProgress.Activate;
  374. var
  375.   S: TSession;
  376. begin
  377.   if FSessionLink = nil then begin
  378.     S := Sessions.List[SessionName];
  379.     S.Open;
  380.     Sessions.CurrentSession := S;
  381.     FSessionLink := TSessionLink.Create(S);
  382.     try
  383.       TSessionLink(FSessionLink).Temporary := True;
  384.       TSessionLink(FSessionLink).KeepConnection := False;
  385.       TSessionLink(FSessionLink).FProgress := Self;
  386.     except
  387.       FSessionLink.Free;
  388.       FSessionLink := nil;
  389.       raise;
  390.     end;
  391.   end
  392.   else Sessions.CurrentSession := TDatabase(FSessionLink).Session;
  393. end;
  394.  
  395. procedure TDBProgress.Deactivate;
  396. begin
  397.   if FSessionLink <> nil then begin
  398.     TSessionLink(FSessionLink).FProgress := nil;
  399.     FSessionLink.Free;
  400.     FSessionLink := nil;
  401.   end;
  402. end;
  403.  
  404. function TDBProgress.GetDBSession: TSession;
  405. begin
  406.   Result := Sessions.FindSession(SessionName);
  407.   if Result = nil then
  408. {$IFDEF RX_D3}
  409.     Result := DBTables.Session;
  410. {$ELSE}
  411.     Result := DB.Session;
  412. {$ENDIF}
  413. end;
  414.  
  415. procedure TDBProgress.SetSessionName(const Value: string);
  416. var
  417.   KeepActive, KeepTrace: Boolean;
  418. begin
  419.   if Value <> SessionName then begin
  420.     if not (csDesigning in ComponentState) then begin
  421.       KeepActive := Active;
  422.       KeepTrace := Trace;
  423.       Active := False;
  424.       Trace := False;
  425.       FSessionName := Value;
  426.       Active := KeepActive;
  427.       Trace := KeepTrace;
  428.     end
  429.     else FSessionName := Value;
  430.   end;
  431. end;
  432.  
  433. procedure TDBProgress.SetTrace(Value: Boolean);
  434. begin
  435.   if (FTrace <> Value) or (FStreamedValue and Value) then begin
  436.     if not (csDesigning in ComponentState) then begin
  437.       if Value then begin
  438.         Activate;
  439.         GetDBSession.TraceFlags := FTraceFlags;
  440.         FTraceCallback := TDBCallback.Create(Self, cbTRACE,
  441.           smTraceBufSize, TraceCallBack, dcReplace);
  442.       end
  443.       else if (FTraceCallback <> nil) then begin
  444.         Sessions.CurrentSession := GetDBSession;
  445.         FTraceCallback.Free;
  446.         FTraceCallback := nil;
  447.         if not Active then Deactivate;
  448.       end;
  449.       FTrace := (FTraceCallback <> nil);
  450.     end
  451.     else FTrace := Value;
  452.   end;
  453. end;
  454.  
  455. procedure TDBProgress.SetTraceFlags(Value: TTraceFlags);
  456. begin
  457.   FTraceFlags := Value;
  458.   if Trace then GetDBSession.TraceFlags := FTraceFlags;
  459. end;
  460.  
  461. function TDBProgress.TraceCallBack(CBInfo: Pointer): CBRType;
  462. var
  463.   CurFlag: TTraceFlag;
  464. begin
  465.   Result := cbrUSEDEF;
  466.   if Trace and Assigned(FOnTrace) then begin
  467.     case PTraceDesc(CBInfo)^.eTraceCat of
  468.       traceQPREPARE: CurFlag := tfQPrepare;
  469.       traceQEXECUTE: CurFlag := tfQExecute;
  470.       traceERROR: CurFlag := tfError;
  471.       traceSTMT: CurFlag := tfStmt;
  472.       traceCONNECT: CurFlag := tfConnect;
  473.       traceTRANSACT: CurFlag := tfTransact;
  474.       traceBLOB: CurFlag := tfBlob;
  475.       traceMISC: CurFlag := tfMisc;
  476.       traceVENDOR: CurFlag := tfVendor;
  477. {$IFDEF RX_D3}
  478.       traceDATAIN: CurFlag := tfDataIn;
  479.       traceDATAOUT: CurFlag := tfDataOut;
  480. {$ENDIF RX_D3}
  481.       else Exit;
  482.     end;
  483.     if (CurFlag in TraceFlags) then
  484.       FOnTrace(Self, CurFlag, StrPas(PTraceDesc(CBInfo)^.pszTrace));
  485.   end;
  486. end;
  487.  
  488. {$ENDIF WIN32}
  489.  
  490. procedure TDBProgress.SetMessageControl(Value: TControl);
  491. begin
  492.   FMessageControl := Value;
  493. {$IFDEF WIN32}
  494.   if Value <> nil then Value.FreeNotification(Self);
  495. {$ENDIF}
  496. end;
  497.  
  498. procedure TDBProgress.SetGauge(Value: TControl);
  499. begin
  500.   FGauge := Value;
  501. {$IFDEF WIN32}
  502.   if Value <> nil then Value.FreeNotification(Self);
  503. {$ENDIF}
  504. end;
  505.  
  506. procedure TDBProgress.Notification(AComponent: TComponent; AOperation: TOperation);
  507. begin
  508.   inherited Notification(AComponent, AOperation);
  509.   if AOperation = opRemove then begin
  510.     if AComponent = Gauge then Gauge := nil
  511.     else if AComponent = MessageControl then MessageControl := nil;
  512.   end;
  513. end;
  514.  
  515. function TDBProgress.GenProgressCallback(CBInfo: Pointer): CBRType;
  516. var
  517.   CallInfo: pCBPROGRESSDesc absolute CBInfo;
  518.   AbortOp: Boolean;
  519. begin
  520.   Result := cbrUSEDEF;
  521.   StartTimer;
  522.   if (FTimer <> nil) and FTimer.Enabled {and (GetTickCount > FStartTime)} then
  523.     SetWaitCursor;
  524.   if Assigned(FOnProgress) then begin
  525.     AbortOp := False;
  526.     FOnProgress(Self, AbortOp);
  527.     if AbortOp then Result := cbrABORT;
  528.   end;
  529.   if CallInfo^.iPercentDone >= 0 then SetPercent(CallInfo^.iPercentDone)
  530.   else SetMessage(StrPas(CallInfo^.szMsg));
  531. end;
  532.  
  533. function TDBProgress.QryProgressCallback(CBInfo: Pointer): CBRType;
  534. var
  535.   CallInfo: pDBIQryProgress absolute CBInfo;
  536.   AbortOp: Boolean;
  537.   PcntDone: Double;
  538. begin
  539.   Result := cbrUSEDEF;
  540.   StartTimer;
  541.   {if (FTimer <> nil) and FTimer.Enabled then SetWaitCursor;}
  542.   if Assigned(FOnProgress) then begin
  543.     AbortOp := False;
  544.     FOnProgress(Self, AbortOp);
  545.     if AbortOp then Result := cbrABORT;
  546.   end;
  547.   with CallInfo^ do begin
  548.     PcntDone := (stepsCompleted / Max(1, stepsInQry)) *
  549.       (elemCompleted / Max(1, totElemInStep));
  550.   end;
  551.   SetPercent(Round(PcntDone * 100));
  552. end;
  553.  
  554. function TDBProgress.ProgressMsgValue(const Msg: string): Longint;
  555. begin
  556.   if Msg <> '' then
  557.     Result := StrToIntDef(Trim(Copy(Msg, Pos(':', Msg) + 1, MaxInt)), -1)
  558.   else Result := -1;
  559. end;
  560.  
  561. end.